home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Pascal Super Library
/
Pascal Super Library (CW International)(1997).bin
/
LIBRARY
/
VTOOLS
/
VTLIST.PAS
< prev
next >
Wrap
Pascal/Delphi Source File
|
1995-03-11
|
20KB
|
472 lines
UNIT VTLIST;
INTERFACE
Uses VTFast,VTKey,VTWin,Crt;
Const MaxLines = 255;
MaxLists = 5;
Type ShortString = String[77];
Type ListType = ShortString;
Type Choices = array[1..MaxLines] Of Boolean; { Array that idicates selected topics }
Type ListHook = Procedure(Ch : Byte; Var Refresh : Boolean; ToPick : Byte);
{ Type of procedure that calls each time when key is pressed}
{ Ch - Position code of pressed key | Refresh - if true
viseble topics will
redisplayed
Topic is a current hilighted topic }
Type ListSet = Set of Byte;
Type ListDescription = Record { Description of every listtable }
X,Y : Byte; { TopLeft side of Box }
Lines : Byte; { Showed Lines }
SWidth : Byte; { Width of selector }
EscValid : Boolean; { Is escape valid ? /True - Valid }
BoxT : Byte; { Type of Box }
Beep, { Beep on invalid key ? }
Shadow, { Shadow ? }
Explode : Boolean; { Explode the box ?}
BoxF, { Box Foreground & BackGroun }
BoxB,
InnerF, { Box Inner foreground & backGround }
InnerB : Byte; { Normal Topics are too }
SelTopicF, { Selected Topic Foreground }
SelTopicB : Byte; { &BackGround }
Only1Selection : Boolean; { Can user select 1 topic }
SelChar : Byte; { Indicator for selected topics}
EndChars : ListSet; { PosCode of Keys for finish }
SelChars : ListSet; { PosCode of Keys for select }
ResetSelection : Boolean; { Clear selection before
displaying }
Title : ShortString;
TitF,TitB : Byte;
SavedScr : Pointer;
Selection : Choices; { Section flags }
CallHook : ListHook; { Each time when key is pressed }
End; { procedure has called }
Var Lists : Array[1..MaxLists] of ^ListDescription; { Listtables }
RetLPChar : Byte; { Position code of last pressed key }
RetLAChar : Byte; { ASCII code of last pressed key }
LastHiTop : Byte; { Number of last selected Topic }
UserLHook : Pointer;
Procedure ListInit; { Initialize unit with start parameters. Not recomended
to use it with defined menus }
Procedure DefaultSettings(ListNum : Byte); { Set a listtable with default }
Procedure ClearSelection (ListNum : Byte); { Clears a selected topics }
Procedure AttachList (ListNum : Byte); {Reserve memory for listtable }
{ to use it }
Procedure DeAttachList(ListNum : Byte); {Release reserved memory }
Procedure DefineList(ListNum,Xp,Yp,Box_T,Box_F,Box_B,InF,InB,SelTF,SelTB,
Tit_F,Tit_B : Byte;Tit : ShortString);
{ Defines a list coordinates,colors & etc. }
Procedure SetList(ListNum,Ln,Sw,Sc : Byte; EV,Sh,Ex,O1S,RS,Bp : Boolean);
{ Defines list rules }
Procedure SetHook(ListNum : Byte; CallP : ListHook); { Defines a called procedure }
Procedure SetSelection(ListNum : Byte; Sel : Choices); {Defines a selection of listtable }
Procedure SetEndChars(ListNum : Byte; EndC : ListSet); {Defines a Position
codes of keys for exit from list }
Procedure SetSelectChars(ListNum : Byte; SelC : ListSet);{Defines a Position
codes of keys for select from list }
Procedure ResetList(Var UserList); { Fill the list with ASCII char '0' }
Procedure DisplayList(ListTable,ListLines : Byte; Var UserList);
{ Displays the list of user. UserLines must be of ListType !
ListLines MUST be size of array
ListTable is a rules to display list }
IMPLEMENTATION
Type ListInfo = Record
Attached : Boolean;
Displayed : Boolean;
End;
Var Tmp : Byte;
Akey,PKey : Byte;
LInfo : Array[1..MaxLists] of ListInfo;
Procedure VTListError(ErrC : Byte);
Var Msg : ShortString;
Begin
Write('VTList ERROR #',ErrC);
Case ErrC Of
1 : Msg := '. List MUST be attached first to use.';
2 : Msg := '. Request to reattach list.List allready attached.';
3 : Msg := '. Request to redisplay list.List allready displayed.';
4 : Msg := '. Not enought memory for operation!';
5 : Msg := '. Request to Dispose list. List not attached.';
6 : Msg := '. Request to change list parameters! List is displayed.';
7 : Msg := '. User (input) array is too large!';
End;
WriteLn(Msg);
Halt;
End;
Procedure DefaultSettings(ListNum : Byte);
Var Tmp1 : Byte;
Begin
If Not LInfo[ListNum].Attached Then VTListError(1);
Lists[ListNum]^.CallHook := Nil;
DefineList(ListNum,0,6,1,15,1,14,1,15,red,lightgreen,1,'');
SetList(ListNum,10,0,251,True,True,False,False,True,True);
SetEndChars(ListNum,[28]);
SetSelectChars(ListNum,[57]);
ClearSelection (ListNum);
End;
Procedure ClearSelection(ListNum : Byte);
Var I : Byte;
Begin
If Not LInfo[ListNum].Attached Then VTListError(1);
For I := 1 To MaxLines Do Lists[ListNum]^.Selection[I] := False;
End;
Procedure AttachList (ListNum : Byte);
Begin
If MaxAvail < SizeOf(ListDescription) Then VTListError(4);
LInfo[ListNum].Attached := True;
GetMem(Lists[ListNum],SizeOf(ListDescription));
End;
Procedure DeAttachList(ListNum : Byte);
Begin
If Not LInfo[ListNum].Attached Then VTListError(5);
LInfo[ListNum].Attached := False;
FreeMem(Lists[ListNum],SizeOf(ListDescription));
End;
Procedure DefineList(ListNum,Xp,Yp,Box_T,Box_F,Box_B,InF,InB,SelTF,SelTB,
Tit_F,Tit_B : Byte;Tit : ShortString);
Begin
If Not Linfo[ListNum].Attached Then VTListError(1);
If LInfo[ListNum] .Displayed Then VtListError(6);
With Lists[ListNum]^ Do Begin
X := Xp; Y := Yp; BoxT := Box_T;
BoxF := Box_F; BoxB := Box_B;
InnerF := InF; InnerB := InB;
SelTopicF := SelTF; SelTopicB := SelTB;
TitF := Tit_F; TitB := Tit_B; Title := Tit;
End;
End;
Procedure SetList(ListNum,Ln,Sw,Sc : Byte; EV,Sh,Ex,O1S,RS,Bp : Boolean);
Begin
If Not Linfo[ListNum].Attached Then VTListError(1);
If LInfo[ListNum] .Displayed Then VtListError(6);
With Lists[ListNum]^ Do Begin
Lines := Ln; SWidth := Sw;
SelChar := Sc; EscValid := EV;
Shadow := Sh; Only1Selection := O1S;
Explode := Ex;
ResetSelection := RS; Beep := Bp;
End;
End;
Procedure SetHook(ListNum : Byte; CallP : ListHook);
Begin
If Not Linfo[ListNum].Attached Then VTListError(1);
Lists[ListNum]^.CallHook := CallP;
End;
Procedure SetSelection(ListNum : Byte; Sel : Choices);
Begin
If Not Linfo[ListNum].Attached Then VTListError(1);
If LInfo[ListNum] .Displayed Then VtListError(6);
Lists[ListNum]^.Selection :=Sel;
End;
Procedure SetEndChars(ListNum : Byte; EndC : ListSet);
Begin
If Not Linfo[ListNum].Attached Then VTListError(1);
If LInfo[ListNum] .Displayed Then VtListError(6);
Lists[ListNum]^.EndChars := EndC;
End;
Procedure SetSelectChars(ListNum : Byte; SelC : ListSet);
Begin
If Not Linfo[ListNum].Attached Then VTListError(1);
If LInfo[ListNum] .Displayed Then VtListError(6);
Lists[ListNum]^.SelChars := SelC;
End;
Procedure ResetList(Var UserList);
Begin
FillChar(UserList,SizeOf(userList),#0);
End;
Procedure Clang;
Begin
Sound(1000);
Delay(5);
Nosound;
Delay(1);
Sound(1500);
Delay(7);
NoSound;
End;
{===================******===================}
Procedure DisplayList(ListTable,ListLines : Byte; Var UserList);
Var StartX,StartY, { Left Top Corner }
EndX,EndY, { Right down corner }
UserLines,
DispLines,
DispWidth,
HiTopic,
PrevHiTopic,
StartP,EndP : Word;
CX,CY,CT,CB : Byte;
Function TopicToString(TopN : Byte) : String; { INTERNAL }
{ Converts a user topic to normal string }
Var TmpS : ShortString;
Begin
Move(Mem[Seg(UserList):Ofs(userList)+((TopN-1) * 78)],Mem[Seg(TmpS):Ofs(TmpS)],78);
TopicToString := TmpS;
End; {Topictostring}
Function GrabWidthFromUser : Byte; { Grab a maximal width topic }
Var Temp : Byte;
Temp1 : Byte;
UserL : Byte;
Begin
Temp1 := 0;
For Temp := 1 To ListLines Do
Begin
UserL := Length(TopicToString(Temp));
If UserL > Temp1 Then Temp1 := UserL;
End;
GrabWidthFromUser := Temp1;
End; { GrabWidthFromUser }
Procedure SetParameters(LN : Byte); { Set parameters to display list }
Begin
DispWidth := GrabWidthFromUser;
UserLines := ListLines;{GrabLinesFromUser};
With Lists[LN]^ Do
Begin
If X = 0 Then StartX := 37 - (DispWidth div 2)
Else StartX := X;
If UserLines < Lines Then DispLines := UserLines
Else DispLines := Lines;
If Y = 0 Then StartY := 11 - (DispLines div 2)
Else StartY := Y;
If DispWidth < Length(Title)+1 Then DispWidth := Length(Title)+1;
EndX := StartX+DispWidth+3; { With box ofcourse}
EndY := StartY + DispLines + 1;
StartP := 1; Endp := DispLines;
PrevHiTopic := 1;
HiTopic := 1;
If ResetSelection Then For Tmp := 1 To MaxLines do Selection[Tmp] := False;
SWidth := EndX-StartX-2;
End; { WITH }
End; {SetParameters}
Procedure DisplayTopic(LN,X,Y,F,B,TopN : Byte); { Display a topic }
Var Ch : Char;
CurrTopic : ShortString;
Begin
CurrTopic := TopicToString(TopN);
ColorWrite(X,Y,F,B,CurrTopic + ReplicateChar(DispWidth-Length(CurrTopic),' '));
With Lists[LN]^ Do If Selection[TopN] Then Ch :=Chr(SelChar)
Else Ch := ' ';
ColorWriteChar(X-1,Y,F,B,Ch);
End; { DisplayTopic }
Procedure DisplayVisibleLines(LNum,Start,Stop : Byte); { Refresh visible lines }
Var Tmp : Byte;
Begin
With Lists[LNum]^ Do
For Tmp := Start To Stop Do DisplayTopic(LNum,StartX+2,StartY+Tmp-Start+1,
InnerF,InnerB,Tmp);
End; { DisplayVisibleLines }
Procedure SavePrevScreen(LN : Byte); { Save screen block under displayed list }
Var BlockSize : Word;
Begin
With Lists[LN]^ Do
Begin
If Shadow Then BlockSize := ((EndX-StartX+2) Shl 2) + ((EndY-StartY+1) * 160)
Else BlockSize := ((EndX-StartX) Shl 2) + ((EndY-StartY) * 160);
If MaxAvail < BlockSize Then VTListError(4);
GetMem(SavedScr,BlockSize);
If Shadow Then GetFromScreen(StartX-2,StartY,EndX,EndY+1,SavedScr)
Else GetFromScreen(StartX,StartY,EndX,EndY,SavedScr);
End; { WITH }
End; {SavePrevScreen}
Procedure RestorePrevScreen(LN : Byte); { Restore screen block under displayed list }
Var BlockSize : Word;
Begin
With Lists[LN]^ Do
Begin
If Shadow Then BlockSize := ((EndX-StartX+2) Shl 2) + ((EndY-StartY+1) * 160)
Else BlockSize := ((EndX-StartX) Shl 2) + ((EndY-StartY) * 160);
If Shadow Then PutToScreen(StartX-2,StartY,EndX,EndY+1,SavedScr)
Else PutToScreen(StartX,StartY,EndX,EndY,SavedScr);
FreeMem(SavedScr,BlockSize);
End; { WITH }
End; {RestorePrevScreen}
Procedure DrawList(LN : Byte); { Draw list box }
Begin
With Lists[LN]^ Do
Begin
If Explode Then ExplodeBox(StartX,StartY,EndX,EndY,BoxF,BoxB,BoxT)
Else Begin
ClearText(StartX,StartY,EndX,EndY,BoxF,BoxB);
DrawBox(StartX,StartY,EndX,EndY,BoxT)
End;
If Shadow Then If (StartX > 3) And (EndY < 24) Then DisplayShadow(StartX,StartY,EndX,EndY);
ClearText(StartX+1,StartY+1,EndX-1,EndY-1,InnerF,InnerB);
ColorWriteBetween(StartX,EndX,StartY,TitF,TitB,Title);
End;
End; {DrawList}
Function HaveSelection (LN : Byte) : Boolean; { Search if user have allready }
Var Tmp : Byte; { selected items }
Begin
HaveSelection := False;
With Lists[Ln]^ Do For Tmp := 1 to ListLines Do If Selection[Tmp] Then Begin
HaveSelection := True;
Tmp := ListLines;
End;
End;
Procedure SetLineAttrib(X,X1,Y,F,B : Byte); { Set attributes of line }
Var Tmp : Byte;
Begin
For Tmp := X To X1 do SetCharAttr(Tmp,Y,Attrib(F,B));
End; {SetLineAttrib}
Procedure OperateList; { Here user move bar, select & etc. }
Var Finish : Boolean;
Refresh_State : Boolean;
Begin
Finish := False; Refresh_State := True;
With Lists[ListTable]^ Do
Repeat
If Refresh_State Then Begin { If topcs need to refresh}
DisplayVisibleLines(ListTable,StartP,EndP);
Refresh_State := False;
End;
If EndP < ListLines Then PlainWriteChar(EndX,EndY-1,#25)
Else PlainWriteChar(EndX,EndY-1,Box[Boxt].RightVLine); { If user is in }
If StartP > 1 Then PlainWriteChar(EndX,StartY+1,#24) {beginnig or end of}
Else PlainWriteChar(EndX,StartY+1,Box[Boxt].RightVLine); {list - draw
{ the U/D arrow }
DisplayTopic(ListTable,StartX+2,StartY+PrevHiTopic, { Display previous }
InnerF,InnerB,StartP-1+PrevHiTopic); {hilighted topic }
DisplayTopic(ListTable,StartX+2,StartY+HiTopic, { Display current }
SelTopicF,SelTopicB,StartP-1+HiTopic); {hilighted topic }
SetLineAttrib(StartX+1,StartX+1+SWidth,StartY+PrevHiTopic,InnerF,InnerB);
SetLineAttrib(StartX+1,StartX+1+SWidth,StartY+HiTopic,SelTopicF,SelTopicB);
XY(StartX+1,StartY+HiTopic);
{hilight current and set previous to normal topic }
GetKey(RetLAChar,RetLPChar); { Wait user action }
Case RetLpChar of { Search user action in standart actions }
{ESC} 1 : If EscValid Then Finish := True
Else Clang;
{UP} 72 : Begin
PrevHiTopic := HiTopic;
Dec(HiTopic);
End;
{Down} 80 : Begin
PrevHiTopic := HiTopic;
Inc(HiTopic);
End;
{PgUp} 73 : Begin
If StartP > DispLines+1 Then Begin
StartP := StartP - DispLines;
EndP := EndP - DispLines;
End
Else Begin { If list is in beginnig hilight 1`st topic }
StartP := 1;
EndP :=DispLines;
PrevHiTopic := HiTopic;
HiTopic := 1;
End;
Refresh_State := True;
End;
{PgDn} 81 : Begin
Refresh_State := True;
If EndP < ListLines - DispLines Then Begin
StartP := StartP + DispLines;
EndP := EndP + DispLines;
End
Else Begin { If list is in end hilight last topic }
StartP := ListLines - DispLines+1;
EndP := ListLines;
PrevHiTopic := HiTopic;
HiTopic := UserLines;
End;
End;
{Home} 71 : Begin
Refresh_State := True;
PrevHiTopic := HiTopic;
HiTopic := 1;
StartP := 1;
EndP := DispLines;
End;
{End} 79: Begin
Refresh_State := True;
StartP := ListLines - DispLines+1;
EndP := ListLines;
PrevHiTopic := HiTopic;
HiTopic := UserLines;
End;
End; { CASE }
{ ** Look if in selectchars ** }
If RetLPChar in SelChars Then Case Only1Selection of { If can select more }
False : Selection[StartP+HiTopic-1] := Not Selection[StartP+HiTopic-1];
True : Begin
If Selection[StartP+HiTopic-1] Then Selection[StartP+HiTopic-1] := False
Else If Not HaveSelection(ListTable) Then Selection[StartP+HiTopic-1] := True
Else If Beep Then Clang;
End;
End;
{ ** Look if in chars to finish ** }
If RetLPChar in EndChars Then Finish := True;
If HiTopic < 1 Then Begin { Can the bar moves up }
HiTopic := 1;
If StartP > 1 Then Begin { Is this a start of list }
Dec(StartP);
Dec(EndP);
Refresh_State := True;
End;
End;
If HiTopic > DispLines Then Begin { Can the bar moves down }
HiTopic := DispLines;
If EndP < ListLines Then Begin { Is this a end of list }
Inc(StartP);
Inc(Endp);
Refresh_State := True;
End;
End;
If Addr(CallHook) <> Nil Then { If user have a hook }
{ Yes! Call then user hook } Lists[ListTable]^.CallHook(RetLPChar,Refresh_State,StartP+HiTopic-1);
Until Finish;
LastHiTop := StartP+HiTopic-1;
End; {OperateList}
Begin { DisplayList}
If ListLines > MaxLines Then VTListError(7); { If user is out of range }
If LInfo[ListTable].Displayed then VTListError(6);
If Not LInfo[ListTable].Attached then VTListError(1);
LInfo[ListTable].Displayed := True; { Set that this list is allready displayed }
GetXY(CX,CY); GetCursor(CT,CB);
SmallCursor;
SetParameters(ListTable); { Define Positions, lengths & etc. }
SavePrevScreen(ListTable); { Save screen block }
DrawList(ListTable); { Draw box,shadows & etc. }
OperateList; { Give control to user }
RestorePrevScreen(ListTable); { Restore screen block }
LInfo[ListTable].Displayed := False; { Disable displayed flag of list }
XY(CX,CY);
SetCursor(CT,CB);
End; { DisplayList} { Return in user program }
Procedure ListInit;
Begin
For Tmp := 1 To MaxLists Do With LInfo[Tmp] Do Begin
Attached := False;
Displayed := False;
End;
End;
BEGIN
ListInit;
END.